@@ -1,5 +1,31 @@
Revision history for autovivification
+0.08 2011-01-03 21:00 UTC
+ + Fix : Building on Windows.
+
+0.07 2010-12-31 16:20 UTC
+ + Chg : perl 5.8.3 is required.
+ + Doc : Complements and clarifications.
+ + Fix : Segmentation faults and misbehaviours in threaded applications.
+ + Fix : Compatibility with perl 5.13.7.
+ Thanks Andreas J. König for reporting and Andrew Main for
+ providing a fix.
+ + Fix : Broken linkage on Windows with gcc 3.4, which appears in
+ particular when using ActivePerl's default compiler suite.
+ For those setups, the autovivification shared library will now
+ be linked against the perl dll directly (instead of the import
+ library).
+ + Opt : The pragma takes slightly more time at compile-time, but is
+ slightly faster at run-time.
+ + Tst : Lengthy tests have been ported to Test::Leaner, making the
+ whole test suite about 50% faster.
+ + Tst : Threads tests are now only run on perl 5.13.4 and higher.
+ They could segfault randomly because of what seems to be an
+ internal bug of Perl, which has been addressed in 5.13.4.
+ There is also an environment variable that allows you to
+ forcefully run those tests, but it should be set only for
+ author testing and not for end users.
+
0.06 2010-04-24 17:40 UTC
+ Add : The A_THREADSAFE and A_FORKSAFE constants.
+ Fix : [RT #56870] : "no autovivification" vs Regexp::Common.
@@ -6,23 +6,29 @@ README
autovivification.xs
lib/autovivification.pm
ptable.h
+reap.h
+samples/bench.pl
samples/hash2array.pl
t/00-load.t
t/20-hash.t
t/22-hash-kv.t
t/23-hash-tied.t
+t/24-hash-numerous.t
t/30-array.t
t/31-array-fast.t
t/32-array-kv.t
t/33-array-tied.t
+t/34-array-numerous.t
t/40-scope.t
t/41-padsv.t
t/42-deparse.t
+t/50-threads.t
t/51-threads-teardown.t
t/91-pod.t
t/92-pod-coverage.t
t/95-portability-files.t
t/99-kwalitee.t
+t/lib/Test/Leaner.pm
t/lib/autovivification/TestCases.pm
t/lib/autovivification/TestRequired1.pm
t/lib/autovivification/TestRequired2.pm
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: autovivification
-version: 0.06
+version: 0.08
abstract: Lexically disable autovivification.
author:
- Vincent Pit <perl@profvince.com>
@@ -13,7 +13,7 @@ build_requires:
Test::More: 0
XSLoader: 0
requires:
- perl: 5.008
+ perl: 5.008003
XSLoader: 0
resources:
bugtracker: http://rt.cpan.org/NoAuth/ReportBug.html?Queue=autovivification
@@ -1,10 +1,37 @@
-use 5.008;
+use 5.008003;
use strict;
use warnings;
use ExtUtils::MakeMaker;
+BEGIN {
+ local $@;
+ eval { require Config };
+ die 'OS unsupported' if $@;
+ Config->import(qw<%Config>);
+}
+
my @DEFINES;
+my %macro;
+
+my $is_gcc_34 = 0;
+print "Checking if this is gcc 3.4 on Windows trying to link against an import library... ";
+if ($^O eq 'MSWin32' and not grep /^LD[A-Z]*=/, @ARGV) {
+ my ($libperl, $gccversion) = map $_ || '', @Config{qw<libperl gccversion>};
+ if ($gccversion =~ /^3\.4\.[0-9]+/ and $libperl =~ s/\.lib$//) {
+ $is_gcc_34 = 1;
+ my ($lddlflags, $ldflags) = @Config{qw<lddlflags ldflags>};
+ $_ ||= '', s/-L(?:".*?"|\S+)//g for $lddlflags, $ldflags;
+ $libperl = "-l$libperl";
+ my $libdirs = join ' ',
+ map { s/(?<!\\)((?:\\\\)*")/\\$1/g; qq[-L"$_"] }
+ @Config{qw<bin sitebin>};
+ $macro{LDDLFLAGS} = "$lddlflags $libdirs $libperl";
+ $macro{LDFLAGS} = "$ldflags $libdirs $libperl";
+ $macro{PERL_ARCHIVE} = '',
+ }
+}
+print $is_gcc_34 ? "yes\n" : "no\n";
# Threads, Windows and 5.8.x don't seem to be best friends
if ($^O eq 'MSWin32' && $^V lt v5.9.0) {
@@ -17,6 +44,7 @@ if ($^O eq 'MSWin32' && $^V lt v5.10.1) {
}
@DEFINES = (DEFINE => join ' ', @DEFINES) if @DEFINES;
+%macro = (macro => { %macro }) if %macro; # Beware of the circle
my $dist = 'autovivification';
@@ -56,7 +84,7 @@ WriteMakefile(
PL_FILES => {},
@DEFINES,
PREREQ_PM => \%PREREQ_PM,
- MIN_PERL_VERSION => 5.008,
+ MIN_PERL_VERSION => 5.008003,
META_MERGE => \%META,
dist => {
PREOP => "pod2text $file > \$(DISTVNAME)/README",
@@ -65,4 +93,5 @@ WriteMakefile(
clean => {
FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt"
},
+ %macro,
);
@@ -2,7 +2,7 @@ NAME
autovivification - Lexically disable autovivification.
VERSION
- Version 0.06
+ Version 0.08
SYNOPSIS
no autovivification;
@@ -34,58 +34,83 @@ DESCRIPTION
METHODS
"unimport @opts"
- Magically called when "no autovivification" is encountered. Enables the
- features given in @opts, which can be :
+ Magically called when "no autovivification @opts" is encountered.
+ Enables the features given in @opts, which can be :
* 'fetch'
- Turn off autovivification for rvalue dereferencing expressions, such
- as "$value = $hashref->{key}[$idx]{$field}", "keys
- %{$hashref->{key}}" or "values %{$hashref->{key}}". Starting from
- perl 5.11, it also covers "keys" and "values" on array references.
+ Turns off autovivification for rvalue dereferencing expressions,
+ such as :
+
+ $value = $arrayref->[$idx]
+ $value = $hashref->{$key}
+ keys %$hashref
+ values %$hashref
+
+ Starting from perl 5.11, it also covers "keys" and "values" on array
+ references :
+
+ keys @$arrayref
+ values @$arrayref
+
When the expression would have autovivified, "undef" is returned for
a plain fetch, while "keys" and "values" return 0 in scalar context
and the empty list in list context.
* 'exists'
- Turn off autovivification for dereferencing expressions that are
- parts of an "exists", such as "exists
- $hashref->{key}[$idx]{$field}". '' is returned when the expression
- would have autovivified.
+ Turns off autovivification for dereferencing expressions that are
+ parts of an "exists", such as :
+
+ exists $arrayref->[$idx]
+ exists $hashref->{$key}
+
+ '' is returned when the expression would have autovivified.
* 'delete'
- Turn off autovivification for dereferencing expressions that are
- parts of a "delete", such as "delete $hashref->{key}[$idx]{$field}".
+ Turns off autovivification for dereferencing expressions that are
+ parts of a "delete", such as :
+
+ delete $arrayref->[$idx]
+ delete $hashref->{$key}
+
"undef" is returned when the expression would have autovivified.
* 'store'
- Turn off autovivification for lvalue dereferencing expressions, such
- as "$hashref->{key}[$idx]{$field} = $value" or "for
- ($hashref->{key}[$idx]{$field}) { ... }". An exception is thrown if
- vivification is needed to store the value, which means that
- effectively you can only assign to levels that are already defined
- (in the example, this would require "$hashref->{key}[$idx]" to
- already be a hash reference).
+ Turns off autovivification for lvalue dereferencing expressions,
+ such as :
+
+ $arrayref->[$idx] = $value
+ $hashref->{$key} = $value
+ for ($arrayref->[$idx]) { ... }
+ for ($hashref->{$key}) { ... }
+ function($arrayref->[$idx])
+ function($hashref->{$key})
+
+ An exception is thrown if vivification is needed to store the value,
+ which means that effectively you can only assign to levels that are
+ already defined In the example, this would require $arrayref (resp.
+ $hashref) to already be an array (resp. hash) reference.
* 'warn'
- Emit a warning when an autovivification is avoided.
+ Emits a warning when an autovivification is avoided.
* 'strict'
- Throw an exception when an autovivification is avoided.
+ Throws an exception when an autovivification is avoided.
Each call to "unimport" adds the specified features to the ones already
in use in the current lexical scope.
- When @opts is empty, it defaults to "qw/fetch exists delete/".
+ When @opts is empty, it defaults to "qw<fetch exists delete>".
"import @opts"
- Magically called when "use autovivification" is encountered. Disables
- the features given in @opts, which can be the same as for "unimport".
+ Magically called when "use autovivification @opts" is encountered.
+ Disables the features given in @opts, which can be the same as for
+ "unimport".
Each call to "import" removes the specified features to the ones already
in use in the current lexical scope.
@@ -113,7 +138,10 @@ CAVEATS
slices.
DEPENDENCIES
- perl 5.8.
+ perl 5.8.3.
+
+ A C compiler. This module may happen to build with a C++ compiler as
+ well, but don't rely on it, as no guarantee is made in this regard.
XSLoader (standard since perl 5.006).
@@ -144,7 +172,7 @@ ACKNOWLEDGEMENTS
Matt S. Trout asked for it.
COPYRIGHT & LICENSE
- Copyright 2009,2010 Vincent Pit, all rights reserved.
+ Copyright 2009,2010,2011 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
@@ -21,24 +21,14 @@
#define A_HAS_PERL(R, V, S) (PERL_REVISION > (R) || (PERL_REVISION == (R) && (PERL_VERSION > (V) || (PERL_VERSION == (V) && (PERL_SUBVERSION >= (S))))))
-#undef ENTERn
-#if defined(ENTER_with_name) && !A_HAS_PERL(5, 11, 4)
-# define ENTERn(N) ENTER_with_name(N)
-#else
-# define ENTERn(N) ENTER
-#endif
-
-#undef LEAVEn
-#if defined(LEAVE_with_name) && !A_HAS_PERL(5, 11, 4)
-# define LEAVEn(N) LEAVE_with_name(N)
-#else
-# define LEAVEn(N) LEAVE
-#endif
-
#ifndef A_WORKAROUND_REQUIRE_PROPAGATION
# define A_WORKAROUND_REQUIRE_PROPAGATION !A_HAS_PERL(5, 10, 1)
#endif
+#ifndef A_HAS_RPEEP
+# define A_HAS_RPEEP A_HAS_PERL(5, 13, 5)
+#endif
+
/* ... Thread safety and multiplicity ...................................... */
/* Always safe when the workaround isn't needed */
@@ -57,7 +47,8 @@
# define A_MULTIPLICITY 0
# endif
#endif
-#if A_MULTIPLICITY && !defined(tTHX)
+
+#ifndef tTHX
# define tTHX PerlInterpreter*
#endif
@@ -112,72 +103,104 @@ typedef struct {
#define ptable_hints_store(T, K, V) ptable_hints_store(aTHX_ (T), (K), (V))
#define ptable_hints_free(T) ptable_hints_free(aTHX_ (T))
+#endif /* A_THREADSAFE */
+
+#endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
+
+#if !A_HAS_RPEEP
+
+#define PTABLE_NAME ptable_seen
+#define PTABLE_VAL_FREE(V) NOOP
+
+#include "ptable.h"
+
+/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
+#define ptable_seen_store(T, K, V) ptable_seen_store(aPTBLMS_ (T), (K), (V))
+#define ptable_seen_clear(T) ptable_seen_clear(aPTBLMS_ (T))
+#define ptable_seen_free(T) ptable_seen_free(aPTBLMS_ (T))
+
+#endif /* !A_HAS_RPEEP */
+
+#define A_NEED_CXT ((A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION) || !A_HAS_RPEEP)
+
+#if A_NEED_CXT
+
#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
typedef struct {
+#if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
ptable *tbl; /* It really is a ptable_hints */
tTHX owner;
+#endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
+#if !A_HAS_RPEEP
+ ptable *seen; /* It really is a ptable_seen */
+#endif /* !A_HAS_RPEEP */
} my_cxt_t;
START_MY_CXT
-STATIC SV *a_clone(pTHX_ SV *sv, tTHX owner) {
-#define a_clone(S, O) a_clone(aTHX_ (S), (O))
- CLONE_PARAMS param;
- AV *stashes = NULL;
- SV *dupsv;
-
- if (SvTYPE(sv) == SVt_PVHV && HvNAME_get(sv))
- stashes = newAV();
-
- param.stashes = stashes;
- param.flags = 0;
- param.proto_perl = owner;
-
- dupsv = sv_dup(sv, ¶m);
+#if A_THREADSAFE
- if (stashes) {
- av_undef(stashes);
- SvREFCNT_dec(stashes);
- }
+#if A_WORKAROUND_REQUIRE_PROPAGATION
- return SvREFCNT_inc(dupsv);
-}
+typedef struct {
+ ptable *tbl;
+#if A_HAS_PERL(5, 13, 2)
+ CLONE_PARAMS *params;
+#else
+ CLONE_PARAMS params;
+#endif
+} a_ptable_clone_ud;
+
+#if A_HAS_PERL(5, 13, 2)
+# define a_ptable_clone_ud_init(U, T, O) \
+ (U).tbl = (T); \
+ (U).params = Perl_clone_params_new((O), aTHX)
+# define a_ptable_clone_ud_deinit(U) Perl_clone_params_del((U).params)
+# define a_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), (U)->params))
+#else
+# define a_ptable_clone_ud_init(U, T, O) \
+ (U).tbl = (T); \
+ (U).params.stashes = newAV(); \
+ (U).params.flags = 0; \
+ (U).params.proto_perl = (O)
+# define a_ptable_clone_ud_deinit(U) SvREFCNT_dec((U).params.stashes)
+# define a_dup_inc(S, U) SvREFCNT_inc(sv_dup((S), &((U)->params)))
+#endif
STATIC void a_ptable_clone(pTHX_ ptable_ent *ent, void *ud_) {
- my_cxt_t *ud = ud_;
+ a_ptable_clone_ud *ud = ud_;
a_hint_t *h1 = ent->val;
a_hint_t *h2;
- if (ud->owner == aTHX)
- return;
-
h2 = PerlMemShared_malloc(sizeof *h2);
h2->bits = h1->bits;
- h2->require_tag = PTR2IV(a_clone(INT2PTR(SV *, h1->require_tag), ud->owner));
+ h2->require_tag = PTR2IV(a_dup_inc(INT2PTR(SV *, h1->require_tag), ud));
ptable_hints_store(ud->tbl, ent->key, h2);
}
-STATIC void a_thread_cleanup(pTHX_ void *);
+#endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
+
+#include "reap.h"
STATIC void a_thread_cleanup(pTHX_ void *ud) {
- int *level = ud;
-
- if (*level) {
- *level = 0;
- LEAVE;
- SAVEDESTRUCTOR_X(a_thread_cleanup, level);
- ENTER;
- } else {
- dMY_CXT;
- PerlMemShared_free(level);
- ptable_hints_free(MY_CXT.tbl);
- }
+ dMY_CXT;
+
+#if A_WORKAROUND_REQUIRE_PROPAGATION
+ ptable_hints_free(MY_CXT.tbl);
+#endif /* A_WORKAROUND_REQUIRE_PROPAGATION */
+#if !A_HAS_RPEEP
+ ptable_seen_free(MY_CXT.seen);
+#endif /* !A_HAS_RPEEP */
}
#endif /* A_THREADSAFE */
+#endif /* A_NEED_CXT */
+
+#if A_WORKAROUND_REQUIRE_PROPAGATION
+
STATIC IV a_require_tag(pTHX) {
#define a_require_tag() a_require_tag(aTHX)
const CV *cv, *outside;
@@ -225,7 +248,9 @@ get_enclosing_cv:
STATIC SV *a_tag(pTHX_ UV bits) {
#define a_tag(B) a_tag(aTHX_ (B))
a_hint_t *h;
+#if A_THREADSAFE
dMY_CXT;
+#endif
h = PerlMemShared_malloc(sizeof *h);
h->bits = bits;
@@ -244,7 +269,9 @@ STATIC SV *a_tag(pTHX_ UV bits) {
STATIC UV a_detag(pTHX_ const SV *hint) {
#define a_detag(H) a_detag(aTHX_ (H))
a_hint_t *h;
+#if A_THREADSAFE
dMY_CXT;
+#endif
if (!(hint && SvIOK(hint)))
return 0;
@@ -271,7 +298,7 @@ STATIC UV a_detag(pTHX_ const SV *hint) {
? SvUVX(H) \
: (SvPOK(H) \
? sv_2uv(SvLEN(H) ? (H) : sv_mortalcopy(H)) \
- : 0 \
+ : 0 \
) \
) \
: 0)
@@ -298,7 +325,9 @@ STATIC U32 a_hash = 0;
STATIC UV a_hint(pTHX) {
#define a_hint() a_hint(aTHX)
SV *hint;
-#if A_HAS_PERL(5, 9, 5)
+#ifdef cop_hints_fetch_pvn
+ hint = cop_hints_fetch_pvn(PL_curcop, __PACKAGE__, __PACKAGE_LEN__, a_hash, 0);
+#elif A_HAS_PERL(5, 9, 5)
hint = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash,
NULL,
__PACKAGE__, __PACKAGE_LEN__,
@@ -328,19 +357,23 @@ typedef struct {
/* PerlMemShared_free() needs the [ap]PTBLMS_? default values */
#define ptable_map_store(T, K, V) ptable_map_store(aPTBLMS_ (T), (K), (V))
+#define ptable_map_delete(T, K) ptable_map_delete(aPTBLMS_ (T), (K))
STATIC ptable *a_op_map = NULL;
#ifdef USE_ITHREADS
+
+#define dA_MAP_THX a_op_info a_op_map_tmp_oi
+
STATIC perl_mutex a_op_map_mutex;
-#endif
+
+#define A_LOCK(M) MUTEX_LOCK(M)
+#define A_UNLOCK(M) MUTEX_UNLOCK(M)
STATIC const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
const a_op_info *val;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&a_op_map_mutex);
-#endif
+ A_LOCK(&a_op_map_mutex);
val = ptable_fetch(a_op_map, o);
if (val) {
@@ -348,13 +381,24 @@ STATIC const a_op_info *a_map_fetch(const OP *o, a_op_info *oi) {
val = oi;
}
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&a_op_map_mutex);
-#endif
+ A_UNLOCK(&a_op_map_mutex);
return val;
}
+#define a_map_fetch(O) a_map_fetch((O), &a_op_map_tmp_oi)
+
+#else /* USE_ITHREADS */
+
+#define dA_MAP_THX dNOOP
+
+#define A_LOCK(M) NOOP
+#define A_UNLOCK(M) NOOP
+
+#define a_map_fetch(O) ptable_fetch(a_op_map, (O))
+
+#endif /* !USE_ITHREADS */
+
STATIC const a_op_info *a_map_store_locked(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
#define a_map_store_locked(O, PP, N, F) a_map_store_locked(aPTBLMS_ (O), (PP), (N), (F))
a_op_info *oi;
@@ -373,29 +417,20 @@ STATIC const a_op_info *a_map_store_locked(pPTBLMS_ const OP *o, OP *(*old_pp)(p
STATIC void a_map_store(pPTBLMS_ const OP *o, OP *(*old_pp)(pTHX), void *next, UV flags) {
#define a_map_store(O, PP, N, F) a_map_store(aPTBLMS_ (O), (PP), (N), (F))
-
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&a_op_map_mutex);
-#endif
+ A_LOCK(&a_op_map_mutex);
a_map_store_locked(o, old_pp, next, flags);
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&a_op_map_mutex);
-#endif
+ A_UNLOCK(&a_op_map_mutex);
}
STATIC void a_map_delete(pTHX_ const OP *o) {
#define a_map_delete(O) a_map_delete(aTHX_ (O))
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&a_op_map_mutex);
-#endif
+ A_LOCK(&a_op_map_mutex);
- ptable_map_store(a_op_map, o, NULL);
+ ptable_map_delete(a_op_map, o);
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&a_op_map_mutex);
-#endif
+ A_UNLOCK(&a_op_map_mutex);
}
STATIC const OP *a_map_descend(const OP *o) {
@@ -419,9 +454,7 @@ STATIC void a_map_store_root(pPTBLMS_ const OP *root, OP *(*old_pp)(pTHX), UV fl
a_op_info *oi;
const OP *o = root;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&a_op_map_mutex);
-#endif
+ A_LOCK(&a_op_map_mutex);
roi = a_map_store_locked(o, old_pp, (OP *) root, flags | A_HINT_ROOT);
@@ -436,9 +469,7 @@ STATIC void a_map_store_root(pPTBLMS_ const OP *root, OP *(*old_pp)(pTHX), UV fl
}
}
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&a_op_map_mutex);
-#endif
+ A_UNLOCK(&a_op_map_mutex);
return;
}
@@ -447,9 +478,7 @@ STATIC void a_map_update_flags_topdown(const OP *root, UV flags) {
a_op_info *oi;
const OP *o = root;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&a_op_map_mutex);
-#endif
+ A_LOCK(&a_op_map_mutex);
flags &= ~A_HINT_ROOT;
@@ -461,9 +490,7 @@ STATIC void a_map_update_flags_topdown(const OP *root, UV flags) {
o = a_map_descend(o);
} while (o);
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&a_op_map_mutex);
-#endif
+ A_UNLOCK(&a_op_map_mutex);
return;
}
@@ -473,9 +500,7 @@ STATIC void a_map_update_flags_topdown(const OP *root, UV flags) {
STATIC void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) {
a_op_info *oi;
-#ifdef USE_ITHREADS
- MUTEX_LOCK(&a_op_map_mutex);
-#endif
+ A_LOCK(&a_op_map_mutex);
flags &= ~A_HINT_ROOT;
rflags |= A_HINT_ROOT;
@@ -487,19 +512,17 @@ STATIC void a_map_update_flags_bottomup(const OP *o, UV flags, UV rflags) {
}
oi->flags = rflags;
-#ifdef USE_ITHREADS
- MUTEX_UNLOCK(&a_op_map_mutex);
-#endif
+ A_UNLOCK(&a_op_map_mutex);
return;
}
/* ... Decide whether this expression should be autovivified or not ........ */
-STATIC UV a_map_resolve(const OP *o, a_op_info *oi) {
+STATIC UV a_map_resolve(const OP *o, const a_op_info *oi) {
UV flags = 0, rflags;
const OP *root;
- a_op_info *roi = oi;
+ const a_op_info *roi = oi;
while (!(roi->flags & A_HINT_ROOT))
roi = roi->next;
@@ -529,30 +552,30 @@ cancel:
return oi->flags & A_HINT_ROOT ? 0 : flags;
}
-/* ... Lightweight pp_defined() ............................................ */
-
-STATIC bool a_defined(pTHX_ SV *sv) {
-#define a_defined(S) a_defined(aTHX_ (S))
- bool defined = FALSE;
+/* ... Inspired from pp_defined() .......................................... */
+STATIC int a_undef(pTHX_ SV *sv) {
+#define a_undef(S) a_undef(aTHX_ (S))
switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ return 1;
case SVt_PVAV:
if (AvMAX(sv) >= 0 || SvGMAGICAL(sv)
|| (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
- defined = TRUE;
+ return 0;
break;
case SVt_PVHV:
if (HvARRAY(sv) || SvGMAGICAL(sv)
|| (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
- defined = TRUE;
+ return 0;
break;
default:
SvGETMAGIC(sv);
if (SvOK(sv))
- defined = TRUE;
+ return 0;
}
- return defined;
+ return 1;
}
/* --- PP functions -------------------------------------------------------- */
@@ -566,15 +589,14 @@ STATIC bool a_defined(pTHX_ SV *sv) {
/* ... pp_rv2av ............................................................ */
STATIC OP *a_pp_rv2av(pTHX) {
- a_op_info oi;
- UV flags;
+ dA_MAP_THX;
+ const a_op_info *oi;
dSP;
- a_map_fetch(PL_op, &oi);
- flags = oi.flags;
+ oi = a_map_fetch(PL_op);
- if (flags & A_HINT_DEREF) {
- if (!a_defined(TOPs)) {
+ if (oi->flags & A_HINT_DEREF) {
+ if (a_undef(TOPs)) {
/* We always need to push an empty array to fool the pp_aelem() that comes
* later. */
SV *av;
@@ -583,79 +605,67 @@ STATIC OP *a_pp_rv2av(pTHX) {
PUSHs(av);
RETURN;
}
- } else {
- PL_op->op_ppaddr = oi.old_pp;
}
- return CALL_FPTR(oi.old_pp)(aTHX);
+ return oi->old_pp(aTHX);
}
/* ... pp_rv2hv ............................................................ */
STATIC OP *a_pp_rv2hv_simple(pTHX) {
- a_op_info oi;
- UV flags;
+ dA_MAP_THX;
+ const a_op_info *oi;
dSP;
- a_map_fetch(PL_op, &oi);
- flags = oi.flags;
+ oi = a_map_fetch(PL_op);
- if (flags & A_HINT_DEREF) {
- if (!a_defined(TOPs))
+ if (oi->flags & A_HINT_DEREF) {
+ if (a_undef(TOPs))
RETURN;
- } else {
- PL_op->op_ppaddr = oi.old_pp;
}
- return CALL_FPTR(oi.old_pp)(aTHX);
+ return oi->old_pp(aTHX);
}
STATIC OP *a_pp_rv2hv(pTHX) {
- a_op_info oi;
- UV flags;
+ dA_MAP_THX;
+ const a_op_info *oi;
dSP;
- a_map_fetch(PL_op, &oi);
- flags = oi.flags;
+ oi = a_map_fetch(PL_op);
- if (flags & A_HINT_DEREF) {
- if (!a_defined(TOPs)) {
+ if (oi->flags & A_HINT_DEREF) {
+ if (a_undef(TOPs)) {
SV *hv;
POPs;
hv = sv_2mortal((SV *) newHV());
PUSHs(hv);
RETURN;
}
- } else {
- PL_op->op_ppaddr = oi.old_pp;
}
- return CALL_FPTR(oi.old_pp)(aTHX);
+ return oi->old_pp(aTHX);
}
/* ... pp_deref (aelem,helem,rv2sv,padsv) .................................. */
STATIC OP *a_pp_deref(pTHX) {
- a_op_info oi;
+ dA_MAP_THX;
+ const a_op_info *oi;
UV flags;
dSP;
- a_map_fetch(PL_op, &oi);
- flags = oi.flags;
+ oi = a_map_fetch(PL_op);
+ flags = oi->flags;
if (flags & A_HINT_DEREF) {
OP *o;
- U8 old_private;
-deref:
- old_private = PL_op->op_private;
- PL_op->op_private = ((old_private & ~OPpDEREF) | OPpLVAL_DEFER);
- o = CALL_FPTR(oi.old_pp)(aTHX);
- PL_op->op_private = old_private;
+ o = oi->old_pp(aTHX);
if (flags & (A_HINT_NOTIFY|A_HINT_STORE)) {
SPAGAIN;
- if (!a_defined(TOPs)) {
+ if (a_undef(TOPs)) {
if (flags & A_HINT_STRICT)
croak("Reference vivification forbidden");
else if (flags & A_HINT_WARN)
@@ -666,31 +676,17 @@ deref:
}
return o;
- } else if ((flags & ~A_HINT_ROOT)
- && (PL_op->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
- /* Decide if the expression must autovivify or not.
- * This branch should be called only once by expression. */
- flags = a_map_resolve(PL_op, &oi);
-
- /* We need the updated flags value in the deref branch. */
- if (flags & A_HINT_DEREF)
- goto deref;
}
- /* This op doesn't need to skip autovivification, so restore the original
- * state. */
- PL_op->op_ppaddr = oi.old_pp;
-
- return CALL_FPTR(oi.old_pp)(aTHX);
+ return oi->old_pp(aTHX);
}
/* ... pp_root (exists,delete,keys,values) ................................. */
STATIC OP *a_pp_root_unop(pTHX) {
- a_op_info oi;
dSP;
- if (!a_defined(TOPs)) {
+ if (a_undef(TOPs)) {
POPs;
/* Can only be reached by keys or values */
if (GIMME_V == G_SCALAR) {
@@ -700,16 +696,17 @@ STATIC OP *a_pp_root_unop(pTHX) {
RETURN;
}
- a_map_fetch(PL_op, &oi);
-
- return CALL_FPTR(oi.old_pp)(aTHX);
+ {
+ dA_MAP_THX;
+ const a_op_info *oi = a_map_fetch(PL_op);
+ return oi->old_pp(aTHX);
+ }
}
STATIC OP *a_pp_root_binop(pTHX) {
- a_op_info oi;
dSP;
- if (!a_defined(TOPm1s)) {
+ if (a_undef(TOPm1s)) {
POPs;
POPs;
if (PL_op->op_type == OP_EXISTS)
@@ -718,22 +715,26 @@ STATIC OP *a_pp_root_binop(pTHX) {
RETPUSHUNDEF;
}
- a_map_fetch(PL_op, &oi);
-
- return CALL_FPTR(oi.old_pp)(aTHX);
+ {
+ dA_MAP_THX;
+ const a_op_info *oi = a_map_fetch(PL_op);
+ return oi->old_pp(aTHX);
+ }
}
/* --- Check functions ----------------------------------------------------- */
STATIC void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) {
#define a_recheck_rv2xv(O, T, PP) a_recheck_rv2xv(aTHX_ (O), (T), (PP))
- a_op_info oi;
if (o->op_type == type && o->op_ppaddr != new_pp
- && cUNOPo->op_first->op_type != OP_GV
- && a_map_fetch(o, &oi)) {
- a_map_store(o, o->op_ppaddr, oi.next, oi.flags);
- o->op_ppaddr = new_pp;
+ && cUNOPo->op_first->op_type != OP_GV) {
+ dA_MAP_THX;
+ const a_op_info *oi = a_map_fetch(o);
+ if (oi) {
+ a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
+ o->op_ppaddr = new_pp;
+ }
}
return;
@@ -741,49 +742,22 @@ STATIC void a_recheck_rv2xv(pTHX_ OP *o, OPCODE type, OP *(*new_pp)(pTHX)) {
/* ... ck_pad{any,sv} ...................................................... */
-/* Sadly, the PADSV OPs we are interested in don't trigger the padsv check
- * function, but are instead manually mutated from a PADANY. This is why we set
- * PL_ppaddr[OP_PADSV] in the padany check function so that PADSV OPs will have
- * their op_ppaddr set to our pp_padsv. PL_ppaddr[OP_PADSV] is then reset at the
- * beginning of every ck_pad{any,sv}. Some unwanted OPs can still call our
- * pp_padsv, but much less than if we would have set PL_ppaddr[OP_PADSV]
- * globally. */
-
-STATIC OP *(*a_pp_padsv_saved)(pTHX) = 0;
-
-STATIC void a_pp_padsv_save(void) {
- if (a_pp_padsv_saved)
- return;
-
- a_pp_padsv_saved = PL_ppaddr[OP_PADSV];
- PL_ppaddr[OP_PADSV] = a_pp_deref;
-}
-
-STATIC void a_pp_padsv_restore(OP *o) {
- if (!a_pp_padsv_saved)
- return;
-
- if (o->op_ppaddr == a_pp_deref)
- o->op_ppaddr = a_pp_padsv_saved;
-
- PL_ppaddr[OP_PADSV] = a_pp_padsv_saved;
- a_pp_padsv_saved = 0;
-}
+/* Sadly, the padsv OPs we are interested in don't trigger the padsv check
+ * function, but are instead manually mutated from a padany. So we store
+ * the op entry in the op map in the padany check function, and we set their
+ * op_ppaddr member in our peephole optimizer replacement below. */
STATIC OP *(*a_old_ck_padany)(pTHX_ OP *) = 0;
STATIC OP *a_ck_padany(pTHX_ OP *o) {
UV hint;
- a_pp_padsv_restore(o);
-
- o = CALL_FPTR(a_old_ck_padany)(aTHX_ o);
+ o = a_old_ck_padany(aTHX_ o);
hint = a_hint();
- if (hint & A_HINT_DO) {
- a_pp_padsv_save();
- a_map_store_root(o, a_pp_padsv_saved, hint);
- } else
+ if (hint & A_HINT_DO)
+ a_map_store_root(o, o->op_ppaddr, hint);
+ else
a_map_delete(o);
return o;
@@ -794,9 +768,7 @@ STATIC OP *(*a_old_ck_padsv)(pTHX_ OP *) = 0;
STATIC OP *a_ck_padsv(pTHX_ OP *o) {
UV hint;
- a_pp_padsv_restore(o);
-
- o = CALL_FPTR(a_old_ck_padsv)(aTHX_ o);
+ o = a_old_ck_padsv(aTHX_ o);
hint = a_hint();
if (hint & A_HINT_DO) {
@@ -838,7 +810,7 @@ STATIC OP *a_ck_deref(pTHX_ OP *o) {
old_ck = a_old_ck_rv2sv;
break;
}
- o = CALL_FPTR(old_ck)(aTHX_ o);
+ o = old_ck(aTHX_ o);
if (hint & A_HINT_DO) {
a_map_store_root(o, o->op_ppaddr, hint);
@@ -868,7 +840,7 @@ STATIC OP *a_ck_rv2xv(pTHX_ OP *o) {
case OP_RV2AV: old_ck = a_old_ck_rv2av; new_pp = a_pp_rv2av; break;
case OP_RV2HV: old_ck = a_old_ck_rv2hv; new_pp = a_pp_rv2hv_simple; break;
}
- o = CALL_FPTR(old_ck)(aTHX_ o);
+ o = old_ck(aTHX_ o);
if (cUNOPo->op_first->op_type == OP_GV)
return o;
@@ -907,7 +879,7 @@ STATIC OP *a_ck_xslice(pTHX_ OP *o) {
a_recheck_rv2xv(cUNOPo->op_first->op_sibling, OP_RV2HV, a_pp_rv2hv);
break;
}
- o = CALL_FPTR(old_ck)(aTHX_ o);
+ o = old_ck(aTHX_ o);
if (hint & A_HINT_DO) {
a_map_store_root(o, 0, hint);
@@ -955,7 +927,7 @@ STATIC OP *a_ck_root(pTHX_ OP *o) {
enabled = hint & A_HINT_FETCH;
break;
}
- o = CALL_FPTR(old_ck)(aTHX_ o);
+ o = old_ck(aTHX_ o);
if (hint & A_HINT_DO) {
if (enabled) {
@@ -971,6 +943,134 @@ STATIC OP *a_ck_root(pTHX_ OP *o) {
return o;
}
+/* ... Our peephole optimizer .............................................. */
+
+STATIC peep_t a_old_peep = 0; /* This is actually the rpeep past 5.13.5 */
+
+#if !A_HAS_RPEEP
+# define A_PEEP_REC_PROTO STATIC void a_peep_rec(pTHX_ OP *o, ptable *seen)
+#else /* !A_HAS_RPEEP */
+# define A_PEEP_REC_PROTO STATIC void a_peep_rec(pTHX_ OP *o)
+#endif /* A_HAS_RPEEP */
+
+A_PEEP_REC_PROTO;
+A_PEEP_REC_PROTO {
+#if !A_HAS_RPEEP
+# define a_peep_rec(O) a_peep_rec(aTHX_ (O), seen)
+#else /* !A_HAS_RPEEP */
+# define a_peep_rec(O) a_peep_rec(aTHX_ (O))
+#endif /* A_HAS_RPEEP */
+ dA_MAP_THX;
+
+#if !A_HAS_RPEEP
+ if (ptable_fetch(seen, o))
+ return;
+#endif
+
+ for (; o; o = o->op_next) {
+ const a_op_info *oi = NULL;
+ UV flags = 0;
+
+#if !A_HAS_RPEEP
+ ptable_seen_store(seen, o, o);
+#endif
+ switch (o->op_type) {
+ case OP_PADSV:
+ if (o->op_ppaddr != a_pp_deref) {
+ oi = a_map_fetch(o);
+ if (oi && (oi->flags & A_HINT_DO)) {
+ a_map_store(o, o->op_ppaddr, oi->next, oi->flags);
+ o->op_ppaddr = a_pp_deref;
+ }
+ }
+ /* FALLTHROUGH */
+ case OP_AELEM:
+ case OP_AELEMFAST:
+ case OP_HELEM:
+ case OP_RV2SV:
+ if (o->op_ppaddr != a_pp_deref)
+ break;
+ oi = a_map_fetch(o);
+ if (!oi)
+ break;
+ flags = oi->flags;
+ if (!(flags & A_HINT_DEREF)
+ && (flags & A_HINT_DO)
+ && (o->op_private & OPpDEREF || flags & A_HINT_ROOT)) {
+ /* Decide if the expression must autovivify or not. */
+ flags = a_map_resolve(o, oi);
+ }
+ if (flags & A_HINT_DEREF)
+ o->op_private = ((o->op_private & ~OPpDEREF) | OPpLVAL_DEFER);
+ else
+ o->op_ppaddr = oi->old_pp;
+ break;
+ case OP_RV2AV:
+ case OP_RV2HV:
+ if ( o->op_ppaddr != a_pp_rv2av
+ && o->op_ppaddr != a_pp_rv2hv
+ && o->op_ppaddr != a_pp_rv2hv_simple)
+ break;
+ oi = a_map_fetch(o);
+ if (!oi)
+ break;
+ if (!(oi->flags & A_HINT_DEREF))
+ o->op_ppaddr = oi->old_pp;
+ break;
+#if !A_HAS_RPEEP
+ case OP_MAPWHILE:
+ case OP_GREPWHILE:
+ case OP_AND:
+ case OP_OR:
+ case OP_ANDASSIGN:
+ case OP_ORASSIGN:
+ case OP_COND_EXPR:
+ case OP_RANGE:
+# if A_HAS_PERL(5, 10, 0)
+ case OP_ONCE:
+ case OP_DOR:
+ case OP_DORASSIGN:
+# endif
+ a_peep_rec(cLOGOPo->op_other);
+ break;
+ case OP_ENTERLOOP:
+ case OP_ENTERITER:
+ a_peep_rec(cLOOPo->op_redoop);
+ a_peep_rec(cLOOPo->op_nextop);
+ a_peep_rec(cLOOPo->op_lastop);
+ break;
+# if A_HAS_PERL(5, 9, 5)
+ case OP_SUBST:
+ a_peep_rec(cPMOPo->op_pmstashstartu.op_pmreplstart);
+ break;
+# else
+ case OP_QR:
+ case OP_MATCH:
+ case OP_SUBST:
+ a_peep_rec(cPMOPo->op_pmreplstart);
+ break;
+# endif
+#endif /* !A_HAS_RPEEP */
+ default:
+ break;
+ }
+ }
+}
+
+STATIC void a_peep(pTHX_ OP *o) {
+#if !A_HAS_RPEEP
+ dMY_CXT;
+ ptable *seen = MY_CXT.seen;
+
+ ptable_seen_clear(seen);
+#endif /* !A_HAS_RPEEP */
+
+ a_old_peep(aTHX_ o);
+ a_peep_rec(o);
+}
+
+/* --- Interpreter setup/teardown ------------------------------------------ */
+
STATIC U32 a_initialized = 0;
STATIC void a_teardown(pTHX_ void *root) {
@@ -983,12 +1083,17 @@ STATIC void a_teardown(pTHX_ void *root) {
return;
#endif
-#if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
+#if A_NEED_CXT
{
dMY_CXT;
+# if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
ptable_hints_free(MY_CXT.tbl);
+# endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
+# if !A_HAS_RPEEP
+ ptable_seen_free(MY_CXT.seen);
+# endif /* !A_HAS_RPEEP */
}
-#endif
+#endif /* A_NEED_CXT */
PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_old_ck_padany);
a_old_ck_padany = 0;
@@ -1021,10 +1126,12 @@ STATIC void a_teardown(pTHX_ void *root) {
PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_old_ck_values);
a_old_ck_values = 0;
- if (a_pp_padsv_saved) {
- PL_ppaddr[OP_PADSV] = a_pp_padsv_saved;
- a_pp_padsv_saved = 0;
- }
+#if A_HAS_RPEEP
+ PL_rpeepp = a_old_peep;
+#else
+ PL_peepp = a_old_peep;
+#endif
+ a_old_peep = 0;
a_initialized = 0;
}
@@ -1034,13 +1141,18 @@ STATIC void a_setup(pTHX) {
if (a_initialized)
return;
-#if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
+#if A_NEED_CXT
{
MY_CXT_INIT;
+# if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
MY_CXT.tbl = ptable_new();
MY_CXT.owner = aTHX;
+# endif /* A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION */
+# if !A_HAS_RPEEP
+ MY_CXT.seen = ptable_new();
+# endif /* !A_RPEEP */
}
-#endif
+#endif /* A_NEED_CXT */
a_old_ck_padany = PL_check[OP_PADANY];
PL_check[OP_PADANY] = MEMBER_TO_FPTR(a_ck_padany);
@@ -1073,6 +1185,14 @@ STATIC void a_setup(pTHX) {
a_old_ck_values = PL_check[OP_VALUES];
PL_check[OP_VALUES] = MEMBER_TO_FPTR(a_ck_root);
+#if A_HAS_RPEEP
+ a_old_peep = PL_rpeepp;
+ PL_rpeepp = a_peep;
+#else
+ a_old_peep = PL_peepp;
+ PL_peepp = a_peep;
+#endif
+
#if A_MULTIPLICITY
call_atexit(a_teardown, aTHX);
#else
@@ -1090,8 +1210,8 @@ MODULE = autovivification PACKAGE = autovivification
PROTOTYPES: ENABLE
-BOOT:
-{
+BOOT:
+{
if (!a_booted++) {
HV *stash;
@@ -1117,34 +1237,47 @@ BOOT:
a_setup();
}
-#if A_THREADSAFE && A_WORKAROUND_REQUIRE_PROPAGATION
+#if A_THREADSAFE && (A_WORKAROUND_REQUIRE_PROPAGATION || !A_HAS_RPEEP)
void
CLONE(...)
PROTOTYPE: DISABLE
PREINIT:
+#if A_WORKAROUND_REQUIRE_PROPAGATION
ptable *t;
- int *level;
-CODE:
+#endif
+#if !A_HAS_RPEEP
+ ptable *s;
+#endif
+PPCODE:
{
- my_cxt_t ud;
dMY_CXT;
- ud.tbl = t = ptable_new();
- ud.owner = MY_CXT.owner;
- ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud);
+#if A_WORKAROUND_REQUIRE_PROPAGATION
+ {
+ a_ptable_clone_ud ud;
+
+ t = ptable_new();
+ a_ptable_clone_ud_init(ud, t, MY_CXT.owner);
+ ptable_walk(MY_CXT.tbl, a_ptable_clone, &ud);
+ a_ptable_clone_ud_deinit(ud);
+ }
+#endif
+#if !A_HAS_RPEEP
+ s = ptable_new();
+#endif
}
{
MY_CXT_CLONE;
+#if A_WORKAROUND_REQUIRE_PROPAGATION
MY_CXT.tbl = t;
MY_CXT.owner = aTHX;
+#endif
+#if !A_HAS_RPEEP
+ MY_CXT.seen = s;
+#endif
}
- {
- level = PerlMemShared_malloc(sizeof *level);
- *level = 1;
- LEAVEn("sub");
- SAVEDESTRUCTOR_X(a_thread_cleanup, level);
- ENTERn("sub");
- }
+ reap(3, a_thread_cleanup, NULL);
+ XSRETURN(0);
#endif
@@ -1,6 +1,6 @@
package autovivification;
-use 5.008;
+use 5.008003;
use strict;
use warnings;
@@ -11,13 +11,13 @@ autovivification - Lexically disable autovivification.
=head1 VERSION
-Version 0.06
+Version 0.08
=cut
our $VERSION;
BEGIN {
- $VERSION = '0.06';
+ $VERSION = '0.08';
}
=head1 SYNOPSIS
@@ -55,7 +55,7 @@ BEGIN {
=head2 C<unimport @opts>
-Magically called when C<no autovivification> is encountered.
+Magically called when C<no autovivification @opts> is encountered.
Enables the features given in C<@opts>, which can be :
=over 4
@@ -64,48 +64,75 @@ Enables the features given in C<@opts>, which can be :
C<'fetch'>
-Turn off autovivification for rvalue dereferencing expressions, such as C<< $value = $hashref->{key}[$idx]{$field} >>, C<< keys %{$hashref->{key}} >> or C<< values %{$hashref->{key}} >>.
-Starting from perl C<5.11>, it also covers C<keys> and C<values> on array references.
+Turns off autovivification for rvalue dereferencing expressions, such as :
+
+ $value = $arrayref->[$idx]
+ $value = $hashref->{$key}
+ keys %$hashref
+ values %$hashref
+
+Starting from perl C<5.11>, it also covers C<keys> and C<values> on array references :
+
+ keys @$arrayref
+ values @$arrayref
+
When the expression would have autovivified, C<undef> is returned for a plain fetch, while C<keys> and C<values> return C<0> in scalar context and the empty list in list context.
=item *
C<'exists'>
-Turn off autovivification for dereferencing expressions that are parts of an C<exists>, such as C<< exists $hashref->{key}[$idx]{$field} >>.
+Turns off autovivification for dereferencing expressions that are parts of an C<exists>, such as :
+
+ exists $arrayref->[$idx]
+ exists $hashref->{$key}
+
C<''> is returned when the expression would have autovivified.
=item *
C<'delete'>
-Turn off autovivification for dereferencing expressions that are parts of a C<delete>, such as C<< delete $hashref->{key}[$idx]{$field} >>.
+Turns off autovivification for dereferencing expressions that are parts of a C<delete>, such as :
+
+ delete $arrayref->[$idx]
+ delete $hashref->{$key}
+
C<undef> is returned when the expression would have autovivified.
=item *
C<'store'>
-Turn off autovivification for lvalue dereferencing expressions, such as C<< $hashref->{key}[$idx]{$field} = $value >> or C<< for ($hashref->{key}[$idx]{$field}) { ... } >>.
-An exception is thrown if vivification is needed to store the value, which means that effectively you can only assign to levels that are already defined (in the example, this would require C<< $hashref->{key}[$idx] >> to already be a hash reference).
+Turns off autovivification for lvalue dereferencing expressions, such as :
+
+ $arrayref->[$idx] = $value
+ $hashref->{$key} = $value
+ for ($arrayref->[$idx]) { ... }
+ for ($hashref->{$key}) { ... }
+ function($arrayref->[$idx])
+ function($hashref->{$key})
+
+An exception is thrown if vivification is needed to store the value, which means that effectively you can only assign to levels that are already defined
+In the example, this would require C<$arrayref> (resp. C<$hashref>) to already be an array (resp. hash) reference.
=item *
C<'warn'>
-Emit a warning when an autovivification is avoided.
+Emits a warning when an autovivification is avoided.
=item *
C<'strict'>
-Throw an exception when an autovivification is avoided.
+Throws an exception when an autovivification is avoided.
=back
Each call to C<unimport> adds the specified features to the ones already in use in the current lexical scope.
-When C<@opts> is empty, it defaults to C<qw/fetch exists delete/>.
+When C<@opts> is empty, it defaults to C<< qw<fetch exists delete> >>.
=cut
@@ -121,7 +148,7 @@ my %bits = (
sub unimport {
shift;
my $hint = _detag($^H{+(__PACKAGE__)}) || 0;
- @_ = qw/fetch exists delete/ unless @_;
+ @_ = qw<fetch exists delete> unless @_;
$hint |= $bits{$_} for grep exists $bits{$_}, @_;
$^H |= 0x00020000;
$^H{+(__PACKAGE__)} = _tag($hint);
@@ -130,7 +157,7 @@ sub unimport {
=head2 C<import @opts>
-Magically called when C<use autovivification> is encountered.
+Magically called when C<use autovivification @opts> is encountered.
Disables the features given in C<@opts>, which can be the same as for L</unimport>.
Each call to C<import> removes the specified features to the ones already in use in the current lexical scope.
@@ -171,7 +198,10 @@ If warnings are turned on, Perl will complain about one-element slices.
=head1 DEPENDENCIES
-L<perl> 5.8.
+L<perl> 5.8.3.
+
+A C compiler.
+This module may happen to build with a C++ compiler as well, but don't rely on it, as no guarantee is made in this regard.
L<XSLoader> (standard since perl 5.006).
@@ -204,7 +234,7 @@ Matt S. Trout asked for it.
=head1 COPYRIGHT & LICENSE
-Copyright 2009,2010 Vincent Pit, all rights reserved.
+Copyright 2009,2010,2011 Vincent Pit, all rights reserved.
This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
@@ -9,6 +9,13 @@
/* This header is designed to be included several times with different
* definitions for PTABLE_NAME and PTABLE_VAL_FREE(). */
+#undef VOID2
+#ifdef __cplusplus
+# define VOID2(T, P) static_cast<T>(P)
+#else
+# define VOID2(T, P) (P)
+#endif
+
#undef pPTBLMS
#undef pPTBLMS_
#undef aPTBLMS
@@ -22,7 +29,7 @@
# define aPTBLMS aTHX
# define aPTBLMS_ aTHX_
#else
-# define pPTBLMS
+# define pPTBLMS void
# define pPTBLMS_
# define aPTBLMS
# define aPTBLMS_
@@ -79,10 +86,11 @@ typedef struct ptable {
#ifndef ptable_new
STATIC ptable *ptable_new(pPTBLMS) {
#define ptable_new() ptable_new(aPTBLMS)
- ptable *t = PerlMemShared_malloc(sizeof *t);
- t->max = 63;
- t->items = 0;
- t->ary = PerlMemShared_calloc(t->max + 1, sizeof *t->ary);
+ ptable *t = VOID2(ptable *, PerlMemShared_malloc(sizeof *t));
+ t->max = 63;
+ t->items = 0;
+ t->ary = VOID2(ptable_ent **,
+ PerlMemShared_calloc(t->max + 1, sizeof *t->ary));
return t;
}
#endif /* !ptable_new */
@@ -125,7 +133,7 @@ STATIC void ptable_split(pPTBLMS_ ptable * const t) {
size_t newsize = oldsize * 2;
size_t i;
- ary = PerlMemShared_realloc(ary, newsize * sizeof(*ary));
+ ary = VOID2(ptable_ent **, PerlMemShared_realloc(ary, newsize * sizeof(*ary)));
Zero(&ary[oldsize], newsize - oldsize, sizeof(*ary));
t->max = --newsize;
t->ary = ary;
@@ -157,7 +165,7 @@ STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const ke
ent->val = val;
} else if (val) {
const size_t i = PTABLE_HASH(key) & t->max;
- ent = PerlMemShared_malloc(sizeof *ent);
+ ent = VOID2(ptable_ent *, PerlMemShared_malloc(sizeof *ent));
ent->key = key;
ent->val = val;
ent->next = t->ary[i];
@@ -168,6 +176,27 @@ STATIC void PTABLE_PREFIX(_store)(pPTBL_ ptable * const t, const void * const ke
}
}
+STATIC void PTABLE_PREFIX(_delete)(pPTBL_ ptable * const t, const void * const key) {
+ ptable_ent *prev, *ent;
+ const size_t i = PTABLE_HASH(key) & t->max;
+
+ prev = NULL;
+ ent = t->ary[i];
+ for (; ent; prev = ent, ent = ent->next) {
+ if (ent->key == key)
+ break;
+ }
+
+ if (ent) {
+ if (prev)
+ prev->next = ent->next;
+ else
+ t->ary[i] = ent->next;
+ PTABLE_VAL_FREE(ent->val);
+ PerlMemShared_free(ent);
+ }
+}
+
#ifndef ptable_walk
STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent, void *userdata), void *userdata) {
#define ptable_walk(T, CB, UD) ptable_walk(aTHX_ (T), (CB), (UD))
@@ -177,7 +206,8 @@ STATIC void ptable_walk(pTHX_ ptable * const t, void (*cb)(pTHX_ ptable_ent *ent
do {
ptable_ent *entry;
for (entry = array[i]; entry; entry = entry->next)
- cb(aTHX_ entry, userdata);
+ if (entry->val)
+ cb(aTHX_ entry, userdata);
} while (i--);
}
}
@@ -0,0 +1,81 @@
+/* This file is part of the autovivification Perl module.
+ * See http://search.cpan.org/dist/autovivification/ */
+
+/* This header provides a specialized version of Scope::Upper::reap that can be
+ * called directly from XS.
+ * See http://search.cpan.org/dist/Scope-Upper/ for details. */
+
+#ifndef REAP_H
+#define REAP_H 1
+
+#define REAP_DESTRUCTOR_SIZE 3
+
+typedef struct {
+ I32 depth;
+ I32 *origin;
+ void (*cb)(pTHX_ void *);
+ void *ud;
+ char *dummy;
+} reap_ud;
+
+STATIC void reap_pop(pTHX_ void *);
+
+STATIC void reap_pop(pTHX_ void *ud_) {
+ reap_ud *ud = ud_;
+ I32 depth, *origin, mark, base;
+
+ depth = ud->depth;
+ origin = ud->origin;
+ mark = origin[depth];
+ base = origin[depth - 1];
+
+ if (base < mark) {
+ PL_savestack_ix = mark;
+ leave_scope(base);
+ }
+ PL_savestack_ix = base;
+
+ if ((ud->depth = --depth) > 0) {
+ SAVEDESTRUCTOR_X(reap_pop, ud);
+ } else {
+ void (*cb)(pTHX_ void *) = ud->cb;
+ void *cb_ud = ud->ud;
+
+ PerlMemShared_free(ud->origin);
+ PerlMemShared_free(ud);
+
+ SAVEDESTRUCTOR_X(cb, cb_ud);
+ }
+}
+
+STATIC void reap(pTHX_ I32 depth, void (*cb)(pTHX_ void *), void *cb_ud) {
+#define reap(D, CB, UD) reap(aTHX_ (D), (CB), (UD))
+ reap_ud *ud;
+ I32 i;
+
+ if (depth > PL_scopestack_ix)
+ depth = PL_scopestack_ix;
+
+ ud = PerlMemShared_malloc(sizeof *ud);
+ ud->depth = depth;
+ ud->origin = PerlMemShared_malloc((depth + 1) * sizeof *ud->origin);
+ ud->cb = cb;
+ ud->ud = cb_ud;
+ ud->dummy = NULL;
+
+ for (i = depth; i >= 1; --i) {
+ I32 j = PL_scopestack_ix - i;
+ ud->origin[depth - i] = PL_scopestack[j];
+ PL_scopestack[j] += REAP_DESTRUCTOR_SIZE;
+ }
+ ud->origin[depth] = PL_savestack_ix;
+
+ while (PL_savestack_ix + REAP_DESTRUCTOR_SIZE
+ <= PL_scopestack[PL_scopestack_ix - 1]) {
+ save_pptr(&ud->dummy);
+ }
+
+ SAVEDESTRUCTOR_X(reap_pop, ud);
+}
+
+#endif /* REAP_H */
@@ -0,0 +1,100 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Benchmark qw<:hireswallclock cmpthese>;
+
+use blib;
+
+my $count = -1;
+
+my @tests;
+
+{
+ my %h = ();
+
+ push @tests, [
+ 'Fetch a non-existing key from a hash',
+ {
+ av => sub { $h{a} },
+ noav => sub { no autovivification; $h{a} },
+ }
+ ];
+}
+
+{
+ my %h = (a => 1);
+
+ push @tests, [
+ 'Fetch an existing key from a hash',
+ {
+ av => sub { $h{a} },
+ noav => sub { no autovivification; $h{a} },
+ }
+ ];
+}
+
+{
+ my $x = { };
+
+ push @tests, [
+ 'Fetch a non-existing key from a hash reference',
+ {
+ av => sub { $x->{a} },
+ noav => sub { no autovivification; $x->{a} },
+ noav_manual => sub { defined $x ? $x->{a} : undef },
+ }
+ ];
+}
+
+{
+ my $x = { a => 1 };
+
+ push @tests, [
+ 'Fetch an existing key from a hash reference',
+ {
+ av => sub { $x->{a} },
+ noav => sub { no autovivification; $x->{a} },
+ noav_manual => sub { defined $x ? $x->{a} : undef },
+ }
+ ];
+}
+
+{
+ my $x = { a => { b => { c => { d => 1 } } } };
+
+ push @tests, [
+ 'Fetch a 4-levels deep existing key from a hash reference',
+ {
+ av => sub { $x->{a}{b}{c}{d} },
+ noav => sub { no autovivification; $x->{a}{b}{c}{d} },
+ noav_manual => sub { my $z; defined $x ? ($z = $x->{a}, defined $z ? ($z = $z->{b}, defined $z ? ($z = $z->{c}, defined $z ? $z->{d} : undef) : undef) : undef) : undef },
+ }
+ ];
+}
+
+{
+ my $x = { };
+ $x->{$_} = undef for 100 .. 199;
+ $x->{$_} = { $_ => 1 } for 200 .. 299;
+ my $n = 0;
+
+ no warnings 'void';
+
+ push @tests, [
+ 'Fetch 2-levels deep existing or non-existing keys from a hash reference',
+ {
+ inc => sub { $n = ($n+1) % 300 },
+ av => sub { $x->{$n}{$n}; $n = ($n+1) % 300 },
+ noav => sub { no autovivification; $x->{$n}{$n}; $n = ($n+1) % 300 },
+ noav_manual => sub { my $z; defined $x ? ($z = $x->{a}, (defined $z ? $z->{b} : undef)) : undef; $n = ($n + 1) % 300 },
+ }
+ ];
+}
+
+for my $t (@tests) {
+ printf "--- %s ---\n", $t->[0];
+ cmpthese $count, $t->[1];
+ print "\n";
+}
@@ -3,8 +3,8 @@
use strict;
use warnings;
-use Fatal qw/open close/;
-use Text::Balanced qw/extract_bracketed/;
+use Fatal qw<open close>;
+use Text::Balanced qw<extract_bracketed>;
open my $hash_t, '<', 't/20-hash.t';
open my $array_t, '>', 't/30-array.t';
@@ -3,9 +3,9 @@
use strict;
use warnings;
-use Test::More tests => 9 * 3 * 290;
-
use lib 't/lib';
+use Test::Leaner tests => 9 * 3 * 302;
+
use autovivification::TestCases;
while (<DATA>) {
@@ -116,6 +116,20 @@ $x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +delete
$x->{a} = 1 # 1 for $x->{a}; () # '', undef, { a => 1 } # +store
$x->{a} = 1 # 1 for $x->{b}; () # '', undef, { a => 1, b => undef } # +store
+$x # do_nothing($x->{a}); () # '', undef, { }
+$x # do_nothing($x->{a}); () # '', undef, { } #
+$x # do_nothing($x->{a}); () # '', undef, { } # +fetch
+$x # do_nothing($x->{a}); () # '', undef, { } # +exists
+$x # do_nothing($x->{a}); () # '', undef, { } # +delete
+$x # do_nothing($x->{a}); () # qr/^Can't vivify reference/, undef, undef # +store
+
+$x # set_arg($x->{a}); () # '', undef, { a => 1 }
+$x # set_arg($x->{a}); () # '', undef, { a => 1 } #
+$x # set_arg($x->{a}); () # '', undef, { a => 1 } # +fetch
+$x # set_arg($x->{a}); () # '', undef, { a => 1 } # +exists
+$x # set_arg($x->{a}); () # '', undef, { a => 1 } # +delete
+$x # set_arg($x->{a}); () # qr/^Can't vivify reference/, undef, undef # +store
+
--- dereferencing ---
$x # no warnings 'uninitialized'; my @a = %$x; () # ($strict ? qr/^Can't use an undefined value as a HASH reference/ : ''), undef, undef
@@ -3,13 +3,13 @@
use strict;
use warnings;
-use Test::More;
+use lib 't/lib';
+use Test::Leaner;
BEGIN {
plan tests => 9 * 3 * 64;
}
-use lib 't/lib';
use autovivification::TestCases;
while (<DATA>) {
@@ -0,0 +1,152 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2 * 2 * 4;
+
+my $n = 100;
+
+{
+ my $w;
+ {
+ my $r;
+ no autovivification;
+ $r = $w->{a}{b} for 1 .. $n;
+ }
+ is_deeply $w, undef, 'numerous fetches from an undef lexical';
+
+ $w = { a => undef };
+ {
+ my $r;
+ no autovivification;
+ $r = $w->{a}{b} for 1 .. $n;
+ }
+ is_deeply $w, { a => undef },'numerous fetches from a 1-level hashref lexical';
+}
+
+{
+ our $w;
+ {
+ my $r;
+ no autovivification;
+ $r = $w->{a}{b} for 1 .. $n;
+ }
+ is_deeply $w, undef, 'numerous fetches from an undef global';
+
+ $w = { a => undef };
+ {
+ my $r;
+ no autovivification;
+ $r = $w->{a}{b} for 1 .. $n;
+ }
+ is_deeply $w, { a => undef },'numerous fetches from a 1-level hashref global';
+}
+
+{
+ my $x;
+ {
+ my @r;
+ no autovivification;
+ @r = @{$x}{qw<a b>} for 1 .. $n;
+ }
+ is_deeply $x, undef, 'numerous slices from an undef lexical';
+
+ $x = { a => undef };
+ {
+ my @r;
+ no autovivification;
+ @r = @{$x->{a}}{qw<b c>} for 1 .. $n;
+ }
+ is_deeply $x, { a => undef }, 'numerous slices from a 1-level hashref lexical';
+}
+
+{
+ our $x;
+ {
+ my @r;
+ no autovivification;
+ @r = @{$x}{qw<a b>} for 1 .. $n;
+ }
+ is_deeply $x, undef, 'numerous slices from an undef global';
+
+ $x = { a => undef };
+ {
+ my @r;
+ no autovivification;
+ @r = @{$x->{a}}{qw<b c>} for 1 .. $n;
+ }
+ is_deeply $x, { a => undef }, 'numerous slices from a 1-level hashref global';
+}
+
+{
+ my $y;
+ {
+ my $r;
+ no autovivification;
+ $r = exists $y->{a}{b} for 1 .. $n;
+ }
+ is_deeply $y, undef, 'numerous exists from an undef lexical';
+
+ $y = { a => undef };
+ {
+ my $r;
+ no autovivification;
+ $r = exists $y->{a}{b} for 1 .. $n;
+ }
+ is_deeply $y, { a => undef },'numerous exists from a 1-level hashref lexical';
+}
+
+{
+ our $y;
+ {
+ my $r;
+ no autovivification;
+ $r = exists $y->{a}{b} for 1 .. $n;
+ }
+ is_deeply $y, undef, 'numerous exists from an undef global';
+
+ $y = { a => undef };
+ {
+ my $r;
+ no autovivification;
+ $r = exists $y->{a}{b} for 1 .. $n;
+ }
+ is_deeply $y, { a => undef },'numerous exists from a 1-level hashref global';
+}
+
+{
+ my $z;
+ {
+ my $r;
+ no autovivification;
+ $r = delete $z->{a}{b} for 1 .. $n;
+ }
+ is_deeply $z, undef, 'numerous deletes from an undef lexical';
+
+ $z = { a => undef };
+ {
+ my $r;
+ no autovivification;
+ $r = delete $z->{a}{b} for 1 .. $n;
+ }
+ is_deeply $z, { a => undef },'numerous deletes from a 1-level hashref lexical';
+}
+
+{
+ our $z;
+ {
+ my $r;
+ no autovivification;
+ $r = delete $z->{a}{b} for 1 .. $n;
+ }
+ is_deeply $z, undef, 'numerous deletes from an undef global';
+
+ $z = { a => undef };
+ {
+ my $r;
+ no autovivification;
+ $r = delete $z->{a}{b} for 1 .. $n;
+ }
+ is_deeply $z, { a => undef },'numerous deletes from a 1-level hashref global';
+}
@@ -3,9 +3,9 @@
use strict;
use warnings;
-use Test::More tests => 9 * 3 * 290;
-
use lib 't/lib';
+use Test::Leaner tests => 9 * 3 * 302;
+
use autovivification::TestCases;
while (<DATA>) {
@@ -116,6 +116,20 @@ $x->[$N[0]] = 1 # 1 for $x->[$N[1]]; () # '', undef, [ 1, undef ] # +delete
$x->[$N[0]] = 1 # 1 for $x->[$N[0]]; () # '', undef, [ 1 ] # +store
$x->[$N[0]] = 1 # 1 for $x->[$N[1]]; () # '', undef, [ 1, undef ] # +store
+$x # do_nothing($x->[$N[0]]); () # '', undef, [ ]
+$x # do_nothing($x->[$N[0]]); () # '', undef, [ ] #
+$x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # +fetch
+$x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # +exists
+$x # do_nothing($x->[$N[0]]); () # '', undef, [ ] # +delete
+$x # do_nothing($x->[$N[0]]); () # qr/^Can't vivify reference/, undef, undef # +store
+
+$x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ]
+$x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] #
+$x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # +fetch
+$x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # +exists
+$x # set_arg($x->[$N[0]]); () # '', undef, [ 1 ] # +delete
+$x # set_arg($x->[$N[0]]); () # qr/^Can't vivify reference/, undef, undef # +store
+
--- dereferencing ---
$x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef
@@ -3,9 +3,9 @@
use strict;
use warnings;
-use Test::More tests => 9 * 3 * 290;
-
use lib 't/lib';
+use Test::Leaner tests => 9 * 3 * 302;
+
use autovivification::TestCases;
while (<DATA>) {
@@ -116,6 +116,20 @@ $x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +delete
$x->[0] = 1 # 1 for $x->[0]; () # '', undef, [ 1 ] # +store
$x->[0] = 1 # 1 for $x->[1]; () # '', undef, [ 1, undef ] # +store
+$x # do_nothing($x->[0]); () # '', undef, [ ]
+$x # do_nothing($x->[0]); () # '', undef, [ ] #
+$x # do_nothing($x->[0]); () # '', undef, [ ] # +fetch
+$x # do_nothing($x->[0]); () # '', undef, [ ] # +exists
+$x # do_nothing($x->[0]); () # '', undef, [ ] # +delete
+$x # do_nothing($x->[0]); () # qr/^Can't vivify reference/, undef, undef # +store
+
+$x # set_arg($x->[0]); () # '', undef, [ 1 ]
+$x # set_arg($x->[0]); () # '', undef, [ 1 ] #
+$x # set_arg($x->[0]); () # '', undef, [ 1 ] # +fetch
+$x # set_arg($x->[0]); () # '', undef, [ 1 ] # +exists
+$x # set_arg($x->[0]); () # '', undef, [ 1 ] # +delete
+$x # set_arg($x->[0]); () # qr/^Can't vivify reference/, undef, undef # +store
+
--- dereferencing ---
$x # no warnings 'uninitialized'; my @a = @$x; () # ($strict ? qr/^Can't use an undefined value as an ARRAY reference/ : ''), undef, undef
@@ -3,13 +3,13 @@
use strict;
use warnings;
-use Test::More;
+use lib 't/lib';
+use Test::Leaner;
BEGIN {
if ($] >= 5.011) { plan tests => 9 * 3 * 64 } else { plan skip_all => 'perl 5.11 required for keys/values @array' }
}
-use lib 't/lib';
use autovivification::TestCases;
while (<DATA>) {
@@ -0,0 +1,152 @@
+#!perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 2 * 2 * 4;
+
+my $n = 100;
+my $i = 0;
+
+{
+ my $w;
+ {
+ my $r;
+ no autovivification;
+ $r = $w->[0][$i] for 1 .. $n;
+ }
+ is_deeply $w, undef, 'numerous fetches from an undef lexical';
+
+ $w = [ undef ];
+ {
+ my $r;
+ no autovivification;
+ $r = $w->[0][$i] for 1 .. $n;
+ }
+ is_deeply $w, [ undef ], 'numerous fetches from a 1-level arrayref lexical';
+}
+
+{
+ our $w;
+ {
+ my $r;
+ no autovivification;
+ $r = $w->[0][$i] for 1 .. $n;
+ }
+ is_deeply $w, undef, 'numerous fetches from an undef global';
+
+ $w = [ undef ];
+ {
+ my $r;
+ no autovivification;
+ $r = $w->[0][$i] for 1 .. $n;
+ }
+ is_deeply $w, [ undef ], 'numerous fetches from a 1-level arrayref global';
+}
+
+{
+ my $x;
+ {
+ my @r;
+ no autovivification;
+ @r = @{$x}[0, 1] for 1 .. $n;
+ }
+ is_deeply $x, undef, 'numerous slices from an undef lexical';
+
+ $x = [ undef ];
+ {
+ my @r;
+ no autovivification;
+ @r = @{$x->[0]}[0, 1] for 1 .. $n;
+ }
+ is_deeply $x, [ undef ], 'numerous slices from a 1-level arrayref lexical';
+}
+
+{
+ our $x;
+ {
+ my @r;
+ no autovivification;
+ @r = @{$x}[0, 1] for 1 .. $n;
+ }
+ is_deeply $x, undef, 'numerous slices from an undef global';
+
+ $x = [ undef ];
+ {
+ my @r;
+ no autovivification;
+ @r = @{$x->[0]}[0, 1] for 1 .. $n;
+ }
+ is_deeply $x, [ undef ], 'numerous slices from a 1-level arrayref global';
+}
+{
+ my $y;
+ {
+ my $r;
+ no autovivification;
+ $r = exists $y->[0][$i] for 1 .. $n;
+ }
+ is_deeply $y, undef, 'numerous exists from an undef lexical';
+
+ $y = [ undef ];
+ {
+ my $r;
+ no autovivification;
+ $r = exists $y->[0][$i] for 1 .. $n;
+ }
+ is_deeply $y, [ undef ], 'numerous exists from a 1-level arrayref lexical';
+}
+
+{
+ our $y;
+ {
+ my $r;
+ no autovivification;
+ $r = exists $y->[0][$i] for 1 .. $n;
+ }
+ is_deeply $y, undef, 'numerous exists from an undef global';
+
+ $y = [ undef ];
+ {
+ my $r;
+ no autovivification;
+ $r = exists $y->[0][$i] for 1 .. $n;
+ }
+ is_deeply $y, [ undef ], 'numerous exists from a 1-level arrayref global';
+}
+
+{
+ my $z;
+ {
+ my $r;
+ no autovivification;
+ $r = delete $z->[0][$i] for 1 .. $n;
+ }
+ is_deeply $z, undef, 'numerous deletes from an undef lexical';
+
+ $z = [ undef ];
+ {
+ my $r;
+ no autovivification;
+ $r = delete $z->[0][$i] for 1 .. $n;
+ }
+ is_deeply $z, [ undef ], 'numerous deletes from a 1-level arrayref lexical';
+}
+
+{
+ our $z;
+ {
+ my $r;
+ no autovivification;
+ $r = delete $z->[0][$i] for 1 .. $n;
+ }
+ is_deeply $z, undef, 'numerous deletes from an undef global';
+
+ $z = [ undef ];
+ {
+ my $r;
+ no autovivification;
+ $r = delete $z->[0][$i] for 1 .. $n;
+ }
+ is_deeply $z, [ undef ], 'numerous deletes from a 1-level arrayref global';
+}
@@ -12,7 +12,7 @@ use lib 't/lib';
my $x;
my $res = eval {
local $SIG{__WARN__} = sub { push @w, join '', 'warn:', @_ };
- no autovivification qw/warn fetch/;
+ no autovivification qw<warn fetch>;
$x->{a};
};
is @w, 1, 'warned only once';
@@ -14,7 +14,7 @@ if (eval 'use B::Deparse; 1') {
my $bd = B::Deparse->new;
{
- no autovivification qw/fetch strict/;
+ no autovivification qw<fetch strict>;
sub blech { my $key = $_[0]->{key} }
}
@@ -0,0 +1,94 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+sub skipall {
+ my ($msg) = @_;
+ require Test::More;
+ Test::More::plan(skip_all => $msg);
+}
+
+use Config qw<%Config>;
+
+BEGIN {
+ my $force = $ENV{PERL_AUTOVIVIFICATION_TEST_THREADS} ? 1 : !1;
+ skipall 'This perl wasn\'t built to support threads'
+ unless $Config{useithreads};
+ skipall 'perl 5.13.4 required to test thread safety'
+ unless $force or $] >= 5.013004;
+}
+
+use threads;
+
+use Test::More;
+
+BEGIN {
+ require autovivification;
+ skipall 'This autovivification isn\'t thread safe'
+ unless autovivification::A_THREADSAFE();
+}
+
+my ($threads, $runs);
+BEGIN {
+ $threads = 10;
+ $runs = 2;
+}
+
+BEGIN {
+ plan tests => $threads * $runs * 3 * (1 + 2);
+ defined and diag "Using threads $_" for $threads::VERSION;
+}
+
+{
+ no autovivification;
+
+ sub try {
+ my $tid = threads->tid();
+
+ for my $run (1 .. $runs) {
+ {
+ my $x;
+ my $y = $x->{foo};
+ is $x, undef, "fetch does not autovivify at thread $tid run $run";
+ }
+ {
+ my $x;
+ my $y = exists $x->{foo};
+ is $x, undef, "exists does not autovivify at thread $tid run $run";
+ }
+ {
+ my $x;
+ my $y = delete $x->{foo};
+ is $x, undef, "delete does not autovivify at thread $tid run $run";
+ }
+
+SKIP:
+ {
+ skip 'Hints aren\'t propagated into eval STRING below perl 5.10' => 3 * 2
+ unless $] >= 5.010;
+ {
+ my $x;
+ eval 'my $y = $x->{foo}';
+ is $@, '', "fetch in eval does not croak at thread $tid run $run";
+ is $x, undef, "fetch in eval does not autovivify at thread $tid run $run";
+ }
+ {
+ my $x;
+ eval 'my $y = exists $x->{foo}';
+ is $@, '', "exists in eval does not croak at thread $tid run $run";
+ is $x, undef, "exists in eval does not autovivify at thread $tid run $run";
+ }
+ {
+ my $x;
+ eval 'my $y = delete $x->{foo}';
+ is $@, '', "delete in eval does not croak at thread $tid run $run";
+ is $x, undef, "delete in eval does not autovivify at thread $tid run $run";
+ }
+ }
+ }
+ }
+}
+
+my @t = map threads->create(\&try), 1 .. $threads;
+$_->join for @t;
@@ -3,14 +3,20 @@
use strict;
use warnings;
-use Config qw/%Config/;
+sub skipall {
+ my ($msg) = @_;
+ require Test::More;
+ Test::More::plan(skip_all => $msg);
+}
+
+use Config qw<%Config>;
BEGIN {
- if (!$Config{useithreads}) {
- require Test::More;
- Test::More->import;
- plan(skip_all => 'This perl wasn\'t built to support threads');
- }
+ my $force = $ENV{PERL_AUTOVIVIFICATION_TEST_THREADS} ? 1 : !1;
+ skipall 'This perl wasn\'t built to support threads'
+ unless $Config{useithreads};
+ skipall 'perl 5.13.4 required to test thread safety'
+ unless $force or $] >= 5.013004;
}
use threads;
@@ -19,12 +25,10 @@ use Test::More;
BEGIN {
require autovivification;
- if (autovivification::A_THREADSAFE()) {
- plan tests => 1;
- defined and diag "Using threads $_" for $threads::VERSION;
- } else {
- plan skip_all => 'This autovivification isn\'t thread safe';
- }
+ skipall 'This autovivification isn\'t thread safe'
+ unless autovivification::A_THREADSAFE();
+ plan tests => 1;
+ defined and diag "Using threads $_" for $threads::VERSION;
}
sub run_perl {
@@ -0,0 +1,873 @@
+package Test::Leaner;
+
+use 5.006;
+use strict;
+use warnings;
+
+=head1 NAME
+
+Test::Leaner - A slimmer Test::More for when you favor performance over completeness.
+
+=head1 VERSION
+
+Version 0.02
+
+=cut
+
+our $VERSION = '0.02';
+
+=head1 SYNOPSIS
+
+ use Test::Leaner tests => 10_000;
+ for (1 .. 10_000) {
+ ...
+ is $one, 1, "checking situation $_";
+ }
+
+
+=head1 DESCRIPTION
+
+When profiling some L<Test::More>-based test script that contained about 10 000 unit tests, I realized that 60% of the time was spent in L<Test::Builder> itself, even though every single test actually involved a costly C<eval STRING>.
+
+This module aims to be a partial replacement to L<Test::More> in those situations where you want to run a large number of simple tests.
+Its functions behave the same as their L<Test::More> counterparts, except for the following differences :
+
+=over 4
+
+=item *
+
+Stringification isn't forced on the test operands.
+However, L</ok> honors C<'bool'> overloading, L</is> and L</is_deeply> honor C<'eq'> overloading (and just that one) and L</cmp_ok> honors whichever overloading category corresponds to the specified operator.
+
+=item *
+
+L</pass>, L</fail>, L</ok>, L</is>, L</isnt>, L</like>, L</unlike> and L</cmp_ok> are all guaranteed to return the truth value of the test.
+
+=item *
+
+L</like> and L</unlike> don't special case regular expressions that are passed as C<'/.../'> strings.
+A string regexp argument is always treated as a the source of the regexp, making C<like $text, $rx> and C<like $text, qr[$rx]> equivalent to each other and to C<cmp_ok $text, '=~', $rx> (and likewise for C<unlike>).
+
+=item *
+
+L</cmp_ok> throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants).
+It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator.
+
+=item *
+
+L</is_deeply> doesn't guard for memory cycles.
+If the two first arguments present parallel memory cycles, the test may result in an infinite loop.
+
+=item *
+
+The tests don't output any kind of default diagnostic in case of failure ; the rationale being that if you have a large number of tests and a lot of them are failing, then you don't want to be flooded by diagnostics.
+
+=item *
+
+C<use_ok>, C<require_ok>, C<can_ok>, C<isa_ok>, C<new_ok>, C<subtest>, C<explain>, C<TODO> blocks and C<todo_skip> are not implemented.
+
+=back
+
+=cut
+
+use Exporter ();
+
+my $main_process;
+
+BEGIN {
+ $main_process = $$;
+
+ if ($] >= 5.008 and $INC{'threads.pm'}) {
+ my $use_ithreads = do {
+ require Config;
+ no warnings 'once';
+ $Config::Config{useithreads};
+ };
+ if ($use_ithreads) {
+ require threads::shared;
+ *THREADSAFE = sub () { 1 };
+ }
+ }
+ unless (defined &Test::Leaner::THREADSAFE) {
+ *THREADSAFE = sub () { 0 }
+ }
+}
+
+my ($TAP_STREAM, $DIAG_STREAM);
+
+my ($plan, $test, $failed, $no_diag, $done_testing);
+
+our @EXPORT = qw<
+ plan
+ skip
+ done_testing
+ pass
+ fail
+ ok
+ is
+ isnt
+ like
+ unlike
+ cmp_ok
+ is_deeply
+ diag
+ note
+ BAIL_OUT
+>;
+
+=head1 ENVIRONMENT
+
+=head2 C<PERL_TEST_LEANER_USES_TEST_MORE>
+
+If this environment variable is set, L<Test::Leaner> will replace its functions by those from L<Test::More>.
+Moreover, the symbols that are imported you C<use Test::Leaner> will be those from L<Test::More>, but you can still only import the symbols originally defined in L<Test::Leaner> (hence the functions from L<Test::More> that are not implemented in L<Test::Leaner> will not be imported).
+If your version of L<Test::More> is too old and doesn't have some symbols (like L</note> or L</done_testing>), they will be replaced in L<Test::Leaner> by croaking stubs.
+
+This may be useful if your L<Test::Leaner>-based test script fails and you want extra diagnostics.
+
+=cut
+
+sub _handle_import_args {
+ my @imports;
+
+ my $i = 0;
+ while ($i <= $#_) {
+ my $item = $_[$i];
+ my $splice;
+ if (defined $item) {
+ if ($item eq 'import') {
+ push @imports, @{ $_[$i+1] };
+ $splice = 2;
+ } elsif ($item eq 'no_diag') {
+ lock $plan if THREADSAFE;
+ $no_diag = 1;
+ $splice = 1;
+ }
+ }
+ if ($splice) {
+ splice @_, $i, $splice;
+ } else {
+ ++$i;
+ }
+ }
+
+ return @imports;
+}
+
+if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) {
+ require Test::More;
+
+ my $leaner_stash = \%Test::Leaner::;
+ my $more_stash = \%Test::More::;
+
+ my %valid_imports;
+
+ for (@EXPORT) {
+ my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE}
+ : undef;
+ if (defined $replacement) {
+ $valid_imports{$_} = 1;
+ } else {
+ $replacement = sub {
+ @_ = ("$_ is not implemented in this version of Test::More");
+ goto &croak;
+ };
+ }
+ no warnings 'redefine';
+ $leaner_stash->{$_} = $replacement;
+ }
+
+ my $import = sub {
+ shift;
+ my @imports = &_handle_import_args;
+ @imports = @EXPORT unless @imports;
+ my @test_more_imports;
+ for (@imports) {
+ if ($valid_imports{$_}) {
+ push @test_more_imports, $_;
+ } else {
+ my $pkg = caller;
+ no strict 'refs';
+ *{$pkg."::$_"} = $leaner_stash->{$_};
+ }
+ }
+ my $test_more_import = 'Test::More'->can('import');
+ @_ = (
+ 'Test::More',
+ @_,
+ import => \@test_more_imports,
+ );
+ {
+ lock $plan if THREADSAFE;
+ push @_, 'no_diag' if $no_diag;
+ }
+ goto $test_more_import;
+ };
+
+ no warnings 'redefine';
+ *import = $import;
+
+ return 1;
+}
+
+sub NO_PLAN () { -1 }
+sub SKIP_ALL () { -2 }
+
+BEGIN {
+ if (THREADSAFE) {
+ threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
+ }
+
+ lock $plan if THREADSAFE;
+
+ $plan = undef;
+ $test = 0;
+ $failed = 0;
+}
+
+sub carp {
+ my $level = 1 + ($Test::Builder::Level || 0);
+ my @caller;
+ do {
+ @caller = caller $level--;
+ } while (!@caller and $level >= 0);
+ my ($file, $line) = @caller[1, 2];
+ warn @_, " at $file line $line.\n";
+}
+
+sub croak {
+ my $level = 1 + ($Test::Builder::Level || 0);
+ my @caller;
+ do {
+ @caller = caller $level--;
+ } while (!@caller and $level >= 0);
+ my ($file, $line) = @caller[1, 2];
+ die @_, " at $file line $line.\n";
+}
+
+sub _sanitize_comment {
+ $_[0] =~ s/\n+\z//;
+ $_[0] =~ s/#/\\#/g;
+ $_[0] =~ s/\n/\n# /g;
+}
+
+=head1 FUNCTIONS
+
+The following functions from L<Test::More> are implemented and exported by default.
+
+=head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
+
+See L<Test::More/plan>.
+
+=cut
+
+sub plan {
+ my ($key, $value) = @_;
+
+ return unless $key;
+
+ lock $plan if THREADSAFE;
+
+ croak("You tried to plan twice") if defined $plan;
+
+ my $plan_str;
+
+ if ($key eq 'no_plan') {
+ croak("no_plan takes no arguments") if $value;
+ $plan = NO_PLAN;
+ } elsif ($key eq 'tests') {
+ croak("Got an undefined number of tests") unless defined $value;
+ croak("You said to run 0 tests") unless $value;
+ croak("Number of tests must be a positive integer. You gave it '$value'")
+ unless $value =~ /^\+?[0-9]+$/;
+ $plan = $value;
+ $plan_str = "1..$value";
+ } elsif ($key eq 'skip_all') {
+ $plan = SKIP_ALL;
+ $plan_str = '1..0 # SKIP';
+ if (defined $value) {
+ _sanitize_comment($value);
+ $plan_str .= " $value" if length $value;
+ }
+ } else {
+ my @args = grep defined, $key, $value;
+ croak("plan() doesn't understand @args");
+ }
+
+ if (defined $plan_str) {
+ local $\;
+ print $TAP_STREAM "$plan_str\n";
+ }
+
+ exit 0 if $plan == SKIP_ALL;
+
+ return 1;
+}
+
+sub import {
+ my $class = shift;
+
+ my @imports = &_handle_import_args;
+
+ if (@_) {
+ local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
+ &plan;
+ }
+
+ @_ = ($class, @imports);
+ goto &Exporter::import;
+}
+
+=head2 C<< skip $reason => $count >>
+
+See L<Test::More/skip>.
+
+=cut
+
+sub skip {
+ my ($reason, $count) = @_;
+
+ lock $plan if THREADSAFE;
+
+ if (not defined $count) {
+ carp("skip() needs to know \$how_many tests are in the block")
+ unless defined $plan and $plan == NO_PLAN;
+ $count = 1;
+ } elsif ($count =~ /[^0-9]/) {
+ carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?');
+ $count = 1;
+ }
+
+ for (1 .. $count) {
+ ++$test;
+
+ my $skip_str = "ok $test # skip";
+ if (defined $reason) {
+ _sanitize_comment($reason);
+ $skip_str .= " $reason" if length $reason;
+ }
+
+ local $\;
+ print $TAP_STREAM "$skip_str\n";
+ }
+
+ no warnings 'exiting';
+ last SKIP;
+}
+
+=head2 C<done_testing [ $count ]>
+
+See L<Test::More/done_testing>.
+
+=cut
+
+sub done_testing {
+ my ($count) = @_;
+
+ lock $plan if THREADSAFE;
+
+ $count = $test unless defined $count;
+ croak("Number of tests must be a positive integer. You gave it '$count'")
+ unless $count =~ /^\+?[0-9]+$/;
+
+ if (not defined $plan or $plan == NO_PLAN) {
+ $plan = $count; # $plan can't be NO_PLAN anymore
+ $done_testing = 1;
+ local $\;
+ print $TAP_STREAM "1..$plan\n";
+ } else {
+ if ($done_testing) {
+ @_ = ('done_testing() was already called');
+ goto &fail;
+ } elsif ($plan != $count) {
+ @_ = ("planned to run $plan tests but done_testing() expects $count");
+ goto &fail;
+ }
+ }
+
+ return 1;
+}
+
+=head2 C<ok $ok [, $desc ]>
+
+See L<Test::More/ok>.
+
+=cut
+
+sub ok ($;$) {
+ my ($ok, $desc) = @_;
+
+ lock $plan if THREADSAFE;
+
+ ++$test;
+
+ my $test_str = "ok $test";
+ unless ($ok) {
+ $test_str = "not $test_str";
+ ++$failed;
+ }
+ if (defined $desc) {
+ _sanitize_comment($desc);
+ $test_str .= " - $desc" if length $desc;
+ }
+
+ local $\;
+ print $TAP_STREAM "$test_str\n";
+
+ return $ok;
+}
+
+=head2 C<pass [ $desc ]>
+
+See L<Test::More/pass>.
+
+=cut
+
+sub pass (;$) {
+ unshift @_, 1;
+ goto &ok;
+}
+
+=head2 C<fail [ $desc ]>
+
+See L<Test::More/fail>.
+
+=cut
+
+sub fail (;$) {
+ unshift @_, 0;
+ goto &ok;
+}
+
+=head2 C<is $got, $expected [, $desc ]>
+
+See L<Test::More/is>.
+
+=cut
+
+sub is ($$;$) {
+ my ($got, $expected, $desc) = @_;
+ no warnings 'uninitialized';
+ @_ = (
+ (not(defined $got xor defined $expected) and $got eq $expected),
+ $desc,
+ );
+ goto &ok;
+}
+
+=head2 C<isnt $got, $expected [, $desc ]>
+
+See L<Test::More/isnt>.
+
+=cut
+
+sub isnt ($$;$) {
+ my ($got, $expected, $desc) = @_;
+ no warnings 'uninitialized';
+ @_ = (
+ ((defined $got xor defined $expected) or $got ne $expected),
+ $desc,
+ );
+ goto &ok;
+}
+
+my %binops = (
+ 'or' => 'or',
+ 'xor' => 'xor',
+ 'and' => 'and',
+
+ '||' => 'hor',
+ ('//' => 'dor') x ($] >= 5.010),
+ '&&' => 'hand',
+
+ '|' => 'bor',
+ '^' => 'bxor',
+ '&' => 'band',
+
+ 'lt' => 'lt',
+ 'le' => 'le',
+ 'gt' => 'gt',
+ 'ge' => 'ge',
+ 'eq' => 'eq',
+ 'ne' => 'ne',
+ 'cmp' => 'cmp',
+
+ '<' => 'nlt',
+ '<=' => 'nle',
+ '>' => 'ngt',
+ '>=' => 'nge',
+ '==' => 'neq',
+ '!=' => 'nne',
+ '<=>' => 'ncmp',
+
+ '=~' => 'like',
+ '!~' => 'unlike',
+ ('~~' => 'smartmatch') x ($] >= 5.010),
+
+ '+' => 'add',
+ '-' => 'substract',
+ '*' => 'multiply',
+ '/' => 'divide',
+ '%' => 'modulo',
+ '<<' => 'lshift',
+ '>>' => 'rshift',
+
+ '.' => 'concat',
+ '..' => 'flipflop',
+ '...' => 'altflipflop',
+ ',' => 'comma',
+ '=>' => 'fatcomma',
+);
+
+my %binop_handlers;
+
+sub _create_binop_handler {
+ my ($op) = @_;
+ my $name = $binops{$op};
+ croak("Operator $op not supported") unless defined $name;
+ {
+ local $@;
+ eval <<"IS_BINOP";
+sub is_$name (\$\$;\$) {
+ my (\$got, \$expected, \$desc) = \@_;
+ \@_ = (scalar(\$got $op \$expected), \$desc);
+ goto &ok;
+}
+IS_BINOP
+ die $@ if $@;
+ }
+ $binop_handlers{$op} = do {
+ no strict 'refs';
+ \&{__PACKAGE__."::is_$name"};
+ }
+}
+
+=head2 C<like $got, $regexp_expected [, $desc ]>
+
+See L<Test::More/like>.
+
+=head2 C<unlike $got, $regexp_expected, [, $desc ]>
+
+See L<Test::More/unlike>.
+
+=cut
+
+{
+ no warnings 'once';
+ *like = _create_binop_handler('=~');
+ *unlike = _create_binop_handler('!~');
+}
+
+=head2 C<cmp_ok $got, $op, $expected [, $desc ]>
+
+See L<Test::More/cmp_ok>.
+
+=cut
+
+sub cmp_ok ($$$;$) {
+ my ($got, $op, $expected, $desc) = @_;
+ my $handler = $binop_handlers{$op};
+ unless ($handler) {
+ local $Test::More::Level = ($Test::More::Level || 0) + 1;
+ $handler = _create_binop_handler($op);
+ }
+ @_ = ($got, $expected, $desc);
+ goto $handler;
+}
+
+=head2 C<is_deeply $got, $expected [, $desc ]>
+
+See L<Test::More/is_deeply>.
+
+=cut
+
+BEGIN {
+ local $@;
+ if (eval { require Scalar::Util; 1 }) {
+ *_reftype = \&Scalar::Util::reftype;
+ } else {
+ # Stolen from Scalar::Util::PP
+ require B;
+ my %tmap = qw<
+ B::NULL SCALAR
+
+ B::HV HASH
+ B::AV ARRAY
+ B::CV CODE
+ B::IO IO
+ B::GV GLOB
+ B::REGEXP REGEXP
+ >;
+ *_reftype = sub ($) {
+ my $r = shift;
+
+ return undef unless length ref $r;
+
+ my $t = ref B::svref_2object($r);
+
+ return exists $tmap{$t} ? $tmap{$t}
+ : length ref $$r ? 'REF'
+ : 'SCALAR'
+ }
+ }
+}
+
+sub _deep_ref_check {
+ my ($x, $y, $ry) = @_;
+
+ no warnings qw<numeric uninitialized>;
+
+ if ($ry eq 'ARRAY') {
+ return 0 unless $#$x == $#$y;
+
+ my ($ex, $ey);
+ for (0 .. $#$y) {
+ $ex = $x->[$_];
+ $ey = $y->[$_];
+
+ # Inline the beginning of _deep_check
+ return 0 if defined $ex xor defined $ey;
+
+ next if not(ref $ex xor ref $ey) and $ex eq $ey;
+
+ $ry = _reftype($ey);
+ return 0 if _reftype($ex) ne $ry;
+
+ return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
+ }
+
+ return 1;
+ } elsif ($ry eq 'HASH') {
+ return 0 unless keys(%$x) == keys(%$y);
+
+ my ($ex, $ey);
+ for (keys %$y) {
+ return 0 unless exists $x->{$_};
+ $ex = $x->{$_};
+ $ey = $y->{$_};
+
+ # Inline the beginning of _deep_check
+ return 0 if defined $ex xor defined $ey;
+
+ next if not(ref $ex xor ref $ey) and $ex eq $ey;
+
+ $ry = _reftype($ey);
+ return 0 if _reftype($ex) ne $ry;
+
+ return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
+ }
+
+ return 1;
+ } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
+ return _deep_check($$x, $$y);
+ }
+
+ return 0;
+}
+
+sub _deep_check {
+ my ($x, $y) = @_;
+
+ no warnings qw<numeric uninitialized>;
+
+ return 0 if defined $x xor defined $y;
+
+ # Try object identity/eq overloading first. It also covers the case where
+ # $x and $y are both undefined.
+ # If either $x or $y is overloaded but none has eq overloading, the test will
+ # break at that point.
+ return 1 if not(ref $x xor ref $y) and $x eq $y;
+
+ # Test::More::is_deeply happily breaks encapsulation if the objects aren't
+ # overloaded.
+ my $ry = _reftype($y);
+ return 0 if _reftype($x) ne $ry;
+
+ # Shortcut if $x and $y are both not references and failed the previous
+ # $x eq $y test.
+ return 0 unless $ry;
+
+ # We know that $x and $y are both references of type $ry, without overloading.
+ _deep_ref_check($x, $y, $ry);
+}
+
+sub is_deeply {
+ @_ = (
+ &_deep_check,
+ $_[2],
+ );
+ goto &ok;
+}
+
+sub _diag_fh {
+ my $fh = shift;
+
+ return unless @_;
+
+ lock $plan if THREADSAFE;
+ return if $no_diag;
+
+ my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
+ _sanitize_comment($msg);
+ return unless length $msg;
+
+ local $\;
+ print $fh "# $msg\n";
+
+ return 0;
+};
+
+=head2 C<diag @text>
+
+See L<Test::More/diag>.
+
+=cut
+
+sub diag {
+ unshift @_, $DIAG_STREAM;
+ goto &_diag_fh;
+}
+
+=head2 C<note @text>
+
+See L<Test::More/note>.
+
+=cut
+
+sub note {
+ unshift @_, $TAP_STREAM;
+ goto &_diag_fh;
+}
+
+=head2 C<BAIL_OUT [ $desc ]>
+
+See L<Test::More/BAIL_OUT>.
+
+=cut
+
+sub BAIL_OUT {
+ my ($desc) = @_;
+
+ lock $plan if THREADSAFE;
+
+ my $bail_out_str = 'Bail out!';
+ if (defined $desc) {
+ _sanitize_comment($desc);
+ $bail_out_str .= " $desc" if length $desc; # Two spaces
+ }
+
+ local $\;
+ print $TAP_STREAM "$bail_out_str\n";
+
+ exit 255;
+}
+
+END {
+ if ($main_process == $$ and not $?) {
+ lock $plan if THREADSAFE;
+
+ if (defined $plan) {
+ if ($failed) {
+ $? = $failed <= 254 ? $failed : 254;
+ } elsif ($plan >= 0) {
+ $? = $test == $plan ? 0 : 255;
+ }
+ if ($plan == NO_PLAN) {
+ local $\;
+ print $TAP_STREAM "1..$test\n";
+ }
+ }
+ }
+}
+
+=pod
+
+L<Test::Leaner> also provides some functions of its own, which are never exported.
+
+=head2 C<tap_stream [ $fh ]>
+
+Read/write accessor for the filehandle to which the tests are outputted.
+On write, it also turns autoflush on onto C<$fh>.
+
+Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
+
+Defaults to C<STDOUT>.
+
+=cut
+
+sub tap_stream (;*) {
+ if (@_) {
+ $TAP_STREAM = $_[0];
+
+ my $fh = select $TAP_STREAM;
+ $|++;
+ select $fh;
+ }
+
+ return $TAP_STREAM;
+}
+
+tap_stream *STDOUT;
+
+=head2 C<diag_stream [ $fh ]>
+
+Read/write accessor for the filehandle to which the diagnostics are printed.
+On write, it also turns autoflush on onto C<$fh>.
+
+Just like L</tap_stream>, it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
+
+Defaults to C<STDERR>.
+
+=cut
+
+sub diag_stream (;*) {
+ if (@_) {
+ $DIAG_STREAM = $_[0];
+
+ my $fh = select $DIAG_STREAM;
+ $|++;
+ select $fh;
+ }
+
+ return $DIAG_STREAM;
+}
+
+diag_stream *STDERR;
+
+=head2 C<THREADSAFE>
+
+This constant evaluates to true if and only if L<Test::Leaner> is thread-safe, i.e. when this version of C<perl> is at least 5.8, has been compiled with C<useithreads> defined, and L<threads> has been loaded B<before> L<Test::Leaner>.
+In that case, it also needs a working L<threads::shared>.
+
+=head1 DEPENDENCIES
+
+L<perl> 5.6.
+
+L<Exporter>, L<Test::More>.
+
+=head1 AUTHOR
+
+Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
+
+You can contact me by mail or on C<irc.perl.org> (vincent).
+
+=head1 BUGS
+
+Please report any bugs or feature requests to C<bug-test-leaner at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Leaner>.
+I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc Test::Leaner
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2010 Vincent Pit, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
+
+=cut
+
+1; # End of Test::Leaner
@@ -3,7 +3,7 @@ package autovivification::TestCases;
use strict;
use warnings;
-use Test::More;
+use Test::Leaner;
sub import {
no strict 'refs';
@@ -12,6 +12,10 @@ sub import {
sub in_strict { (caller 0)[8] & (eval { strict::bits(@_) } || 0) };
+sub do_nothing { }
+
+sub set_arg { $_[0] = 1 }
+
sub generate {
my ($var, $init, $code, $exp, $use, $opts, $global) = @_;
my $decl = $global ? "our $var; local $var;" : "my $var;";
@@ -1,5 +1,5 @@
package autovivification::TestRequired4::a0;
-no autovivification qw/strict fetch/;
+no autovivification qw<strict fetch>;
use autovivification::TestRequired4::b0;
sub error {
local $@;
@@ -1,5 +1,5 @@
package autovivification::TestRequired5::a0;
-no autovivification qw/strict fetch/;
+no autovivification qw<strict fetch>;
use autovivification::TestRequired5::b0;
sub error {
local $@;